MacTech 1 to 12

home *** CD-ROM | disk | FTP | other *** search

/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 04 - 1988 / 04.09 Sep 88 / Forth Stuff / AppleTalk_mail next >

Wrap

Text File | 1988-09-06 | 12.4 KB | 598 lines | [TEXT/EDIT]

only forth also assembler \ Appletalk general definitions \ 30.05.88 JL vocabulary network also network definitions DECIMAL 27 constant ioPermission 18 constant ioFileName 18 constant userData 24 constant ioRefNum 26 constant csCode 28 constant socket 30 constant addrBlock 4 constant atpLoadedBit 1 constant useATalk -97 constant portInUse -98 constant portNotCf 9 constant mppUnitNum 10 constant atpUnitNum mppUnitNum 1+ negate constant mppRefNum atpUnitNum 1+ negate constant atpRefNum \ LAP defs 1 constant LAPshortDDP 2 constant LAPLongDDP -94 constant lapProtErr -95 constant lapExcessCollns 243 constant lapWrite 244 constant lapDetachPH 245 constant lapAttachPH -1 constant lapOverrunErr -2 constant lapCRCErr -3 constant lapUnderrunErr -4 constant lapLengthErr \ DDP defs 5 constant ddpHdSzShort 13 constant ddpHdSzLong 1 constant ddpRTMP 2 constant ddpNBP 3 constant ddpATP $7F constant ddpMaxWKS 586 constant ddpMaxData $3ff constant ddpLengthMask 128 constant ddpWKS -91 constant ddpSktErr -92 constant ddpLenErr -93 constant ddpNoBridgeErr \ CsCode values for DDP Control calls- MPP 246 constant ddpWrite 247 constant ddpCloseSkt 248 constant ddpOpenSkt \ RTMP definitions 1 constant rtmpSkt \ NBP definitions $10 constant nbpBrRq $20 constant nbpLkUp $30 constant nbpLkUpReply 2 constant nbpSkt 15 constant nbpTupleMax ascii = constant nbpEquals ascii * constant nbpStar 0 constant ntLink 4 constant ntTuple 7 constant ntSocket 9 constant ntEntity -1024 constant nbpBuffOvr -1025 constant nbpNoConfirm -1026 constant nbpConfDiff -1027 constant nbpDuplicate -1028 constant nbpNotFound -1029 constant nbpNISErr 249 constant nbpLoad 250 constant nbpConfirm 251 constant nbpLookup 252 constant nbpRemove 253 constant nbpRegister 254 constant nbpKill 255 constant nbpUnload 256 constant setSelfSend \ ATP definitions $40 constant atpReqCode $80 constant atpRspCode $C0 constant atpRelCode $20 constant atpXO $10 constant atpEOM $08 constant atpSTS $02 constant atpTidValid $01 constant atpSendChk $3F constant atpFlagMask $F8 constant atpControlMask 8 constant atpMaxNum 578 constant atpMaxData 249 constant atpRelRspCB 250 constant atpCloseSkt 251 constant atpAddResponse 252 constant atpSendResponse 253 constant atpGetRequest 254 constant atpOpenSkt 255 constant atpSendRequest 256 constant atpRelTCB -1096 constant atpReqFailed -1097 constant atpTooManyReqs -1098 constant atpTooManySkts -1099 constant atpBadATPSkt -1100 constant atpBadBuffNum -1101 constant atpNoRelErr -1102 constant atpCBNotFound -1103 constant atpNoSendResp -1104 constant atpNoDataArea -1105 constant atpReqAborted $1FA constant pRamByte $1FB constant SPConfig $291 constant portBUse $2D8 constant ABusVars $2DC constant ABusDCE 0 constant bdsBuffSz 2 constant bdsBuffAddr 6 constant bdsDataSz 8 constant bdsUserData .trap _control,async $a404 header ATPbuffer 2000 allot header myBDS 8 12 * allot header reqBuf 600 allot header myNTE 100 allot header ATPblock 50 allot header MPPName DC.B 4 DC.B '.MPP' header ATPName DC.B 4 DC.B '.ATP' ( Have to make sure that AppleTalk can be run. See if port is occupied) ( pg. 55 from Inside Mac's AppleTalk Guide) : open.atp PortBUse c@ $10 and IF 0 \ Appletalk already open! ELSE ['] ATPName ['] ATPBlock ioFileName + ! 0 ['] ATPBlock ioPermission + c! ['] ATPBlock call Open THEN ; : open.mpp ['] MPPName ['] ATPBlock ioFileName + ! 0 ['] ATPBlock ioPermission + c! ['] ATPBlock call Open ; : OpenATalk { | PBUse -- f } PortBUse c@ -> PBUse PBUse 0< IF SPConfig c@ $F AND useATalk = IF open.mpp ?dup 0= IF open.atp THEN ELSE portNotCf THEN ELSE PBUse $F and useATalk = IF open.atp ELSE portInUse THEN THEN ; : close.atp ATPRefNum ['] ATPBlock ioRefNum + w! ['] ATPBlock call Close ; : call.mpp mppRefNum ['] ATPBlock ioRefNum + w! ['] ATPBlock call control ; : call.atp atpRefNum ['] ATPBlock ioRefNum + w! ['] ATPBlock call control ; : call.atp.async ( p_complete -- flag ) atpRefNum ['] ATPBlock ioRefNum + w! ( p_complete) ['] ATPBlock ioCompletion + ! LEA ATPBlock,A0 EXG D4,A7 _Control,Async EXT.L D0 MOVE.L D0,-(A6) EXG D4,A7 ; : open.socket ( addrBlock socket# -- socket# flag ) ( socket# ) ['] ATPBlock socket + c! ( addrBlock ) ['] ATPBlock addrBlock + ! atpOpenSkt ['] ATPBlock csCode + w! call.atp ['] ATPBlock socket + c@ swap ; : close.socket ( socket# -- flag ) ( socket# ) ['] ATPBlock socket + c! atpCloseSkt ['] ATPBlock csCode + w! call.atp ; : (send.request) ( userData atpFlags addrBlock reqLength reqPointer bdsPointer numOfBuffs timeOutVal retryCount -- reqTID BitMap atpFlags numOfResps flag ) ( retryCount ) ['] ATPBlock 47 + c! ( timeOutVal ) ['] ATPBlock 45 + c! ( numOfBuffs ) ['] ATPBlock 44 + c! ( bdsPointer ) ['] ATPBlock 40 + ! ( reqPointer ) ['] ATPBlock 36 + ! ( reqLength ) ['] ATPBlock 34 + w! ( addrBlock ) ['] ATPBlock 30 + ! ( atpFlags ) ['] ATPBlock 29 + c! ( userData ) ['] ATPBlock 18 + ! atpSendRequest ['] ATPBlock csCode + w! call.atp ['] ATPBlock 16 + w@ ['] ATPBlock 28 + c@ ['] ATPBlock 29 + c@ ['] ATPBlock 46 + c@ 4 roll ( result code ) ; : (get.request) ( atpSocket reqLength reqPointer -- userData atpFlags addrBlock reqLength bitMap transID flag ) ( reqPointer ) ['] ATPBlock 36 + ! ( reqLength ) ['] ATPBlock 34 + w! ( atpSocket ) ['] ATPBlock 28 + c! call.atp ['] ATPBlock 18 + @ ['] ATPBlock 29 + c@ ['] ATPBlock 30 + @ ['] ATPBlock 34 + w@ ['] ATPBlock 44 + c@ ['] ATPBlock 46 + c@ 6 roll ( result code ) ; variable ATPout ( semaphore ) code get.request.compl movem.l a0/a5,-(a7) movea.l currenta5,a5 movea.l ATPout,a0 move.w #wake,(a0) movem.l (a7)+,a0/a5 rts end-code : (get.request.async) ( atpSocket reqLength reqPointer -- userData atpFlags addrBlock reqLength bitMap transID flag ) ATPout get ( reqPointer ) ['] ATPBlock 36 + ! ( reqLength ) ['] ATPBlock 34 + w! ( atpSocket ) ['] ATPBlock 28 + c! ['] get.request.compl call.atp.async sleep status w! pause \ wake up when getRequest is completed ['] ATPBlock 18 + @ ['] ATPBlock 29 + c@ ['] ATPBlock 30 + @ ['] ATPBlock 34 + w@ ['] ATPBlock 44 + c@ ['] ATPBlock 46 + c@ 6 roll ( result code ) ATPout release ; : setup.bds ( #buffers ) 0 DO 600 call NewPtr abort" Could not get buffer memory" i 12 * ['] myBDS + 2+ ! LOOP ; : release.bds ( #buffers ) 0 DO i 12 * ['] myBDS + 2+ @ call DisposPtr abort" DisposPtr failed!" LOOP ; : (send.response) ( atpSocket atpFlags addrBlock bdsPointer numOfBuffs bdsSize transID -- reqTID userData flag ) ( transID ) ['] ATPBlock 46 + w! ( bdsSize ) ['] ATPBlock 45 + c! ( numOfBuffs ) ['] ATPBlock 44 + c! ( bdsPointer ) ['] ATPBlock 40 + ! ( addrBlock ) ['] ATPBlock 30 + ! ( atpFlags ) ['] ATPBlock 29 + c! ( atpSocket ) ['] ATPBlock 28 + c! atpSendResponse ['] ATPBlock csCode + w! call.atp ['] ATPBlock 16 + w@ ['] ATPBlock 18 + @ rot ( result code ) ; : (add.response) ( userData atpSocket atpFlags addrBlock reqLength reqPointer rspNum transID -- flag ) ( transID ) ['] ATPBlock 46 + w! ( rspNum ) ['] ATPBlock 44 + c! ( reqPointer ) ['] ATPBlock 36 + ! ( reqLength ) ['] ATPBlock 34 + w! ( addrBlock ) ['] ATPBlock 30 + ! ( atpFlags ) ['] ATPBlock 29 + c! ( atpSocket ) ['] ATPBlock 28 + c! ( userData ) ['] ATPBlock 18 + ! atpAddResponse ['] ATPBlock csCode + w! call.atp ( result code ) ; : load.nbp nbpLoad ['] ATPBlock csCode + w! call.mpp ; : make.entity { object typ zone entity | obL typL -- } object entity over c@ 1+ dup -> obL cmove typ entity obL + over c@ 1+ dup -> typL cmove zone entity obL + typL + over c@ 1+ cmove ; : (lookup.name) ( interval retry buffer size max entity -- matches flag ) nbpLookup ['] ATPBlock csCode + w! ( entity ) ['] ATPBlock 30 + ! ( max ) ['] ATPBlock 40 + w! ( size ) ['] ATPBlock 38 + w! ( buffer ) ['] ATPBlock 34 + ! ( retry ) ['] ATPBlock 29 + c! ( interval) ['] ATPBlock 28 + c! call.mpp ['] ATPBlock 42 + w@ \ matches found swap \ result code ; : lookup.name ( object typ zone | -- matches flag ) ['] myNTE ntEntity + make.entity 2 10 ['] ATPbuffer 600 20 ['] myNTE ntEntity + (lookup.name) ; : (register.name) ( interval retry ntQEl verify -- flag ) nbpRegister ['] ATPBlock csCode + w! ( verify ) ['] ATPBlock 34 + c! ( ntQEl ) ['] ATPBlock 30 + ! ( retry ) ['] ATPBlock 29 + c! ( interval) ['] ATPBlock 28 + c! call.mpp \ result code ; : register.name ( socket# object typ zone ) { ntQEl | -- flag } ntQEl ntEntity + make.Entity ntQEl ntSocket + c! ( store socket number ) 2 10 ntQEl 1 ( always verify ) (register.name) ; : remove.name ( ntQEl | flag ) nbpRemove ['] ATPBlock csCode + w! ( ntQEl ) ntEntity + ['] ATPBlock 30 + ! call.mpp \ result code ; : set.self.send ( self_send_flag | old_flag -- ) setSelfSend ['] ATPBlock csCode + w! ( flag ) ['] ATPBlock 28 + c! call.mpp drop \ result code ['] ATPBlock 29 + c@ ; 4ascii STR constant "str 4ascii MAIL constant "mail : get.choosername "str -16096 call getresource ?dup IF @ ELSE 1 abort" No Chooser name found!" THEN ; also forth definitions variable mailbox.socket header mailNTE 110 allot : open.mailbox 0 0 open.socket abort" could not get free ATP socket" dup mailbox.socket ! get.choosername " mailbox" " *" ['] mailNTE register.name abort" registerName failed" ; : close.mailbox ['] mailNTE remove.name drop mailbox.socket @ close.socket drop ; : sendOK cr ." ----- Sending OK response....." 1 setup.bds " This mail was received OK." count dup ['] myBDS w! ['] myBDS 2+ @ swap cmove ['] myBDS ['] ATPBlock 40 + ! 1 ['] ATPBlock 44 + c! 1 ['] ATPBlock 45 + c! atpSendResponse ['] ATPBlock csCode + w! call.atp 1 release.bds ; : get.mail { | trID addr.block -- reqTID userData flag } mailbox.socket @ 500 ['] reqBuf (get.request) abort" ATPGetRequest error!" 5 call sysbeep -> trID drop ( don't need bitmap ) cr ." ***** Mail received *****" cr ['] reqBuf swap type cr ." ***** End of mail *****" dup -> addr.block cr ." sender: $" hex . ." , flags: $" . ." , User Data: $" . cr decimal sendOK ; : get.mail.async { | trID addr.block -- reqTID userData flag } mailbox.socket @ 500 ['] reqBuf (get.request.async) abort" ATPGetRequest error!" 5 call sysbeep -> trID drop ( don't need bitmap ) cr ." ***** Mail received *****" cr ['] reqBuf swap type cr ." ***** End of mail *****" dup -> addr.block cr ." sender: $" hex . ." , flags: $" . ." , User Data: $" . cr decimal sendOK ; : >@< ( odd address fetch, unnecessary on MacII ) dup 2 mod IF dup c@ swap 1+ @ -8 scale $FFFFFF and swap 24 scale + ELSE @ THEN ; : next.field dup c@ + 1+ ; : print.entities ( #entities entityTable ) cr swap hex 0 DO ." $" dup >@< u. ." - " 5 + dup count type ." :" next.field dup count type ." @" next.field dup count type cr next.field LOOP drop decimal ; : find.boxes " =" " mailbox" " *" lookup.name abort" LookupName failed" cr ?dup IF dup . ." mailbox(es) found on the network:" cr ['] ATPBuffer print.entities ELSE ." No mailboxes found on the network." cr THEN ; : send.mail { receiver msg | -- } cr ." Sending message to $" receiver hex . decimal ." ..." cr 1 setup.bds "mail %00100000 receiver msg count swap ['] myBDS 1 2 5 (send.request) ?dup IF ." SendRequest error #" . cr ELSE ." Mail delivered" cr THEN . . . . cr 1 release.bds ; \ ===== DEFINE MAIL SENDER AND RECEIVER TASKS ===== also mac NEW.WINDOW Sender " Sender" Sender TITLE 40 20 170 400 Sender BOUNDS Document Visible CloseBox GrowBox Sender ITEMS 400 1000 TERMINAL sendTask NEW.WINDOW Receiver " Mailbox" Receiver TITLE 190 20 320 400 Receiver BOUNDS Document Visible CloseBox GrowBox Receiver ITEMS 400 1000 TERMINAL rcvTask : mail.it activate begin cr ." Searching open mailboxes..." cr find.boxes hex begin cr ." To address (zero to quit): $" pad dup 1+ 10 expect number? until ?dup IF cr ." Message: " pad 1+ 80 expect span pad c! pad send.mail ELSE bye THEN again ; : get.it activate begin cr ." Registering new Mailbox..." open.mailbox cr ." Waiting for mail..." cr get.mail.async drop close.mailbox ?terminal until bye ; : setup.main 0 ATPout ! open.mpp drop open.atp drop 1 set.self.send drop ; : setup.sender setup.main Sender ADD Sender sendTask BUILD Sender call selectwindow sendTask mail.it ; : setup.rcv setup.main Receiver ADD Receiver rcvTask BUILD Receiver call selectwindow rcvTask get.it ;